{--
	- file: FdParser.hs
	- author: ssword
	-
	- just output do_parse 
	-
	- log
		- prototyped operators 
		- prototyped if & while                       @ 5.5 17:05 by Fleurer
		-
		-
--}


module FdParser where

import Monad
import Control.Monad.Error

import FdType

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language (haskellDef)


do_parse :: String -> ThrowsError Expr
do_parse text
	= case (parse rootParser "" text) of 
		Left err -> throwError $ SyntaxErr (show err)
		Right x -> return x



-- ee , i am not quite sure about this		
rootParser :: Parser Expr
rootParser = do {
	whiteSpace;
	exps <- stats;
	return $ Seq $ exps;
}



------------------------------------------------
-- # expressions
------------------------------------------------

expr :: Parser Expr
expr = choice [
	infixExpr,
	simpleExpr
	] <?> "expr"

simpleExpr = choice [ 
	literal,
	try applyExpr,
	try arrayElem,
	ident,
	try $ parens stat,
	parens expr
	] <?> "simple expr"

applyExpr :: Parser Expr
applyExpr = do {
	f <- try arrayElem <|> ident <|> try (parens simpleExpr) <|> parens stat;
	paras <- many1 $ parens $ commaSep $ expr;
	return $ foldl Apply f paras;
}

--infix expr
infixExpr :: Parser Expr                 
infixExpr = buildExpressionParser operators simpleExpr <?> "infix expr"
            where 
				operators = [
					--[fetch "." AssocLeft],
					[prefix "-"],
					[prefix "!"],
					[op "*" AssocLeft, op "/" AssocLeft],
					[op "+" AssocLeft, op "-" AssocLeft],
					[op "==" AssocNone, op "!=" AssocNone, op "<" AssocNone, op ">" AssocNone, op "<" AssocNone, op ">=" AssocNone, op "<=" AssocNone],
					[op "&&" AssocLeft, op "||" AssocLeft],
					[assign "=" AssocRight, op "<<" AssocLeft]]
			    		where 
							op     name   = Infix  (do {reservedOp name; return (\x y -> Apply (Ident name) [x,y] ); }) 
							prefix name   = Prefix (do {reservedOp name; return (\x -> Apply (Ident ("pre_"++name)) [x]); })	
							--fetch  name   = Infix  (do {reservedOp name; return (\arr (Ident i) -> ArrayItem arr (Value (fd_new_string i))); })
							assign name   = Infix  (do {reservedOp name; return (\var exp -> case var of
								   																Ident _ -> Assign var exp
																								ArrayItem _ _ -> Assign var exp )})
			


-------------------------------
-- # literal
-------------------------------

literal :: Parser Expr
literal = try nilLiteral <|> numberLiteral <|> stringLiteral <|> arrayLiteral <|> try hashLiteral <|> try functionLiteral

nilLiteral :: Parser Expr
nilLiteral = do {
    reserved "nil";
    return $ Literal $ NilL;
}

numberLiteral :: Parser Expr
numberLiteral = do {
	v <- integerOrFloat;
	case v of 
		Left i -> 
			return (Literal $ NumberL $ fromInteger i);
		Right f -> 
			return (Literal $ NumberL f);
} <?> "a number literal"

arrayLiteral :: Parser Expr
arrayLiteral = do {
	exps <- brackets $ commaSep $ expr;
	return $ Literal $ ArrayL $ exps;
}

hashLiteral :: Parser Expr
hashLiteral = do {
	exps <- braces $ commaSep $ do {
		k@(Literal _) <- literal;
		symbol ":";
		v <- expr;
		return (k, v);
	};
	return $ Literal $ HashL $ exps;
}

stringLiteral :: Parser Expr
stringLiteral = try (do {
	symbol "'";
	s <- many $ noneOf "'";
	symbol "'";
	return (Literal $ StringL $ s);
}) <|> (do {
    symbol "\"";
    s <- many $ noneOf "\"";
    symbol "\"";
	return $ Literal $ StringL s;
}) <?> "a string Literal"

functionLiteral :: Parser Expr
functionLiteral = do {
	reserved "function";
	funcBody;
} <?> "a function"

--------------------------------
-- # statments
--------------------------------

stat = choice [
	ifStat,
    caseStat,
	whileStat,
	forStat,
	breakStat,
	returnStat,
	inlineStat,
	varStat,
	try defStat,
	seqStat
	]

-- if while break return exp() var function {}

ifStat :: Parser Expr
ifStat = do {
	reserved "if"; 
	cond <- parens expr;  
	exp  <- stat; 
	elseif_part <- many (do{
		reserved "elseif";
		cond <- parens expr;
		exp  <- stat;
		return (cond, exp);
	}) <?> "elseif part";
	else_part <- option Nop (do {
		reserved "else";
		exp <- stat;
		return exp;
	}) <?> "else part";
	return $ If ((cond, exp): elseif_part) else_part;
} <?> "if expr"


caseStat :: Parser Expr
caseStat = do {
    reserved "case";
    exp <- parens expr;
    braces $ (do{
        matches_part <- many (do {
            reserved "of";
            m <- parens expr;
            exp <- stat;
            return (m, exp);
        }) <?> "matches";
        else_part <- option Nop (do {
            reserved "else";
            exp <- stat;
            return exp;
        }) <?> "else part";
        return $ Case exp matches_part else_part;
    });
}

whileStat :: Parser Expr
whileStat = do {
	reserved "while";
	cond <- parens expr;
	exp  <- stat; 
	return $ While cond exp
} <?> "while expr"

forStat :: Parser Expr
forStat = do {
	reserved "for";
	[init,cond,end] <- parens $ do {
		init <- try expr <|> varStat; semi; 
		cond <- expr; semi; 
		end  <- expr; 
		return [init,cond,end];
	};
	exp <- stat;
	return $ Seq [init, While cond (Seq [exp, end])];
}

breakStat :: Parser Expr
breakStat = do {
	reserved "break"; semi;
	return $ Break;
}

returnStat :: Parser Expr
returnStat = do {
	reserved "return";
	exp <- expr; semi;
	return $ Return exp;
}

inlineStat :: Parser Expr
inlineStat = do {
	exp <- expr; semi;
	return exp;
}

varStat :: Parser Expr
varStat = do {
	reserved "var";
	defs <- commaSep1 (do {
		(Ident id) <- ident;
		exp <- option Nop (do {
			reservedOp "=";
			simpleExpr;
		});
		return $ Define id exp;
	});
	return $ Seq defs;
}

defStat :: Parser Expr
defStat = do {
	reserved "function";
	(Ident fname) <- ident;
	fbody <- funcBody;
	return (Define fname fbody)
}

seqStat :: Parser Expr
seqStat = try (do {
    braces $ many $ semi;
    return $ Nop;
}) <|> (do {
	exps <- braces $ stats; 
	return $ Seq exps;
}) <?> "seqence expr"

{--
	- --implement it later
caseExpr :: Parser Expr
caseExpr = do {
	reserved "case";
	exp <- expr; newline;
	reserved "of";
	v <- literal; newline;
	exp1 <- expr;
	reserved "end";
	return $ CaseExpr NopExpr [(NopExpr,NopExpr)] NopExpr;
}
--}

{--
forExpr :: Parser Expr
forExpr = do {
	reserved "for";
	i <- identifier;
	reserved "in";
	a <- expr; newline;
	exp1 <- expr;
	reserved "end";
	return $ For i a exp1;
}
--}


---------------------------------------
-- # ident
---------------------------------------

objs = [ident, arrayElem]

ident :: Parser Expr
ident = do {
	i <- identifier;
	return $ Ident i;
} <?> "ident"

arrayElem :: Parser Expr
arrayElem = do {
	obj <- ident <|> try (parens simpleExpr) <|> parens stat;
	index <- many1 $ brackets $ expr;
	return $ foldl ArrayItem obj index;
}


---------------------------------------
--- # helpers 
--  just to avoid repeatness
---------------------------------------

stats = many $ (do {
    st <- stat; 
    many semi;
    return st;
})


funcBody :: Parser Expr
funcBody = do {
	paras <- parens $ commaSep $ ident;
	pnames <- return $ map (\(Ident n) -> n) paras;
	exp	<- seqStat; 
	return (Literal $ FunctionL pnames exp);
}




---------------------------------------------------
-- lexer
---------------------------------------------------

chunDef  = haskellDef { 
	P.reservedNames  = [ "array", "break", "do", "else", "end", "for", "function", "fn", "if", "elseif", "in", "let", 
						"of", "then", "to", "type", "var", "while" ],
	P.reservedOpNames= [ ".", "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"],
	P.opLetter       = oneOf (concat (P.reservedOpNames chunDef)),
	P.caseSensitive  = True   
}

lexer = P.makeTokenParser chunDef

parens          = P.parens lexer    
braces          = P.braces lexer    
brackets        = P.brackets lexer
semi            = P.semi lexer
colon           = P.colon lexer
semiSep         = P.semiSep lexer  
semiSep1        = P.semiSep1 lexer    
commaSep        = P.commaSep lexer
commaSep1       = P.commaSep1 lexer
whiteSpace      = P.whiteSpace lexer    
symbol          = P.symbol lexer    
identifier      = P.identifier lexer    
reserved        = P.reserved lexer    
reservedOp      = P.reservedOp lexer
integer         = P.integer lexer    
float           = P.float lexer
integerOrFloat  = P.naturalOrFloat lexer
charLiteral     = P.charLiteral lexer    

